home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / audacity / nyquist / fileio.lsp < prev    next >
Encoding:
Lisp/Scheme  |  2010-09-21  |  11.7 KB  |  305 lines
  1. ;; fileio.lsp
  2.  
  3. ;; if *default-sf-dir* undefined, set it to user's tmp directory
  4. ;;
  5. (cond ((not (boundp '*default-sf-dir*))
  6.        ;; it would be nice to use get-temp-path, but when running
  7.        ;; the Java-based IDE, Nyquist does not get environment
  8.        ;; variables to tell TMP or TEMP or USERPROFILE
  9.        ;; We want to avoid the current directory because it may
  10.        ;; be read-only. Search for some likely paths...
  11.        ;; Note that since these paths don't work for Unix or OS X,
  12.        ;; they will not be used, so no system-dependent code is 
  13.        ;; needed
  14.        (let ((current (setdir ".")))
  15.          (setf *default-sf-dir*
  16.                (or (setdir "c:\\tmp\\")
  17.                    (setdir "c:\\temp\\")
  18.                    (setdir "d:\\tmp\\")
  19.                    (setdir "d:\\temp\\")
  20.                    (setdir "e:\\tmp\\")
  21.                    (setdir "e:\\temp\\")
  22.                (get-temp-path)))
  23.          (format t "Set *default-sf-dir* to \"~A\" in fileio.lsp~%" 
  24.          *default-sf-dir*)
  25.      (setdir current))))
  26.  
  27. ;; s-save -- saves a file
  28. (setf NY:ALL 1000000000)    ; 1GIG constant for maxlen
  29. (defmacro s-save (expression &optional (maxlen NY:ALL) filename 
  30.                   &key (format '*default-sf-format*)
  31.                   (mode '*default-sf-mode*) (bits '*default-sf-bits*)
  32.                   (endian NIL) ; nil, :big, or :little -- specifies file format
  33.                   (play nil))
  34.   `(let ((ny:fname ,filename)
  35.          (ny:maxlen ,maxlen)
  36.          (ny:endian ,endian)
  37.          (ny:swap 0))
  38.      ; allow caller to omit maxlen, in which case the filename will
  39.      ; be a string in the maxlen parameter position and filename will be null
  40.      (cond ((null ny:fname)
  41.                  (cond ((stringp ny:maxlen)
  42.                             (setf ny:fname ny:maxlen)
  43.                             (setf ny:maxlen NY:ALL))
  44.                            (t
  45.                             (setf ny:fname *default-sound-file*)))))
  46.      
  47.      (cond ((equal ny:fname "")
  48.                  (cond ((not ,play)
  49.                        (format t "s-save: no file to write! play option is off!\n"))))
  50.            (t
  51.             (setf ny:fname (soundfilename ny:fname))
  52.             (format t "Saving sound file to ~A~%" ny:fname)))
  53.      (cond ((eq ny:endian :big)
  54.             (setf ny:swap (if (bigendianp) 0 1)))
  55.            ((eq ny:endian :little)
  56.             (setf ny:swap (if (bigendianp) 1 0))))
  57.      (snd-save ',expression ny:maxlen ny:fname ,format ,mode ,bits ny:swap ,play)))
  58.  
  59. ;; MULTICHANNEL-MAX -- find peak over all channels
  60. ;;
  61. (defun multichannel-max (snd samples)
  62.   (cond ((soundp snd)
  63.      (snd-max snd samples))
  64.     ((arrayp snd) ;; assume it is multichannel sound
  65.      (let ((peak 0.0) (chans (length snd)))
  66.        (dotimes (i chans)
  67.          (setf peak (max peak (snd-max (aref snd i) (/ samples chans)))))
  68.        peak))
  69.     (t (error "unexpected value in multichannel-max" snd))))
  70.  
  71.  
  72. ;; AUTONORM -- look ahead to find peak and normalize sound to 80%
  73. ;;
  74. (defun autonorm (snd)
  75.   (let (peak)
  76.     (cond (*autonormflag*
  77.        (cond ((and (not (soundp snd))
  78.                (not (eq (type-of snd) 'ARRAY)))
  79.           (error "AUTONORM (or PLAY?) got unexpected value" snd))
  80.          ((eq *autonorm-type* 'previous)
  81.           (scale *autonorm* snd))
  82.          ((eq *autonorm-type* 'lookahead)
  83.           (setf peak (multichannel-max snd *autonorm-max-samples*))
  84.           (setf peak (max 0.001 peak))
  85.                   (setf *autonorm* (/ *autonorm-target* peak))
  86.           (scale *autonorm* snd))
  87.          (t
  88.           (error "unknown *autonorm-type*"))))
  89.       (t snd))))
  90.     
  91.  
  92. (defmacro s-save-autonorm (expression &rest arglist)
  93.   `(let ((peak (s-save (autonorm ,expression) ,@arglist)))
  94.      (autonorm-update peak)))
  95.  
  96. ;; The "AutoNorm" facility: when you play something, the Nyquist play
  97. ;; command will automatically compute what normalization factor you
  98. ;; should have used. If you play the same thing again, the normalization
  99. ;; factor is automatically applied.
  100. ;;
  101. ;; Call AUTONORM-OFF to turn off this feature, and AUTONORM-ON to turn
  102. ;; it back on.
  103. ;;
  104. ;; *autonorm-target* is the peak value we're aiming for (it's set below 1
  105. ;; so allow the next signal to get slightly louder without clipping)
  106. ;;
  107. (init-global *autonorm-target* 0.9)
  108. ;;
  109. ;; *autonorm-type* selects the autonorm algorithm to use
  110. ;;   'previous means normalize according to the last computed sound
  111. ;;   'precompute means precompute *autonorm-max-samples* samples in
  112. ;;       memory and normalize according to the peak
  113. ;;
  114. (init-global *autonorm-type* 'lookahead)
  115. (init-global *autonorm-max-samples* 1000000) ; default is 4MB buffer
  116. ;;
  117. (defun autonorm-on ()
  118.   (setf *autonorm* 1.0)
  119.   (setf *autonorm-previous-peak* 1.0)
  120.   (setf *autonormflag* t)
  121.   (format t "AutoNorm feature is on.~%"))
  122.  
  123. (if (not (boundp '*autonormflag*)) (autonorm-on))
  124.  
  125. (defun autonorm-off ()
  126.   (setf *autonormflag* nil)
  127.   (setf *autonorm* 1.0)
  128.   (format t "AutoNorm feature is off.~%"))
  129.  
  130. ;; AUTONORM-UPDATE -- called with true peak to report and prepare
  131. ;;
  132. ;; after saving/playing a file, we have the true peak. This along
  133. ;; with the autonorm state is printed in a summary and the autonorm
  134. ;; state is updated for next time.
  135. ;;
  136. ;; There are currently two types: PREVIOUS and LOOKAHEAD
  137. ;; With PREVIOUS:
  138. ;;   compute the true peak and print the before and after peak
  139. ;;   along with the scale factor to be used next time
  140. ;; With LOOKAHEAD:
  141. ;;   compute the true peak and print the before and after peak
  142. ;;   along with the "suggested scale factor" that would achieve
  143. ;;   the *autonorm-target*
  144. ;;
  145. (defun autonorm-update (peak)
  146.   (cond ((> peak 1.0)
  147.          (format t "*** CLIPPING DETECTED! ***~%")))
  148.   (cond ((and *autonormflag* (> peak 0.0))
  149.            (setf *autonorm-previous-peak* (/ peak *autonorm*))
  150.          (setf *autonorm* (/ *autonorm-target* *autonorm-previous-peak*))
  151.          (format t "AutoNorm: peak was ~A,~%" *autonorm-previous-peak*)
  152.          (format t "     peak after normalization was ~A,~%" peak)
  153.          (format t (if (eq *autonorm-type* 'PREVIOUS)
  154.                        "     new normalization factor is ~A~%"
  155.                        "     suggested normalization factor is ~A~%")
  156.                  *autonorm*))
  157.         (t
  158.          (format t "Peak was ~A,~%" peak)
  159.          (format t "     suggested normalization factor is ~A~%"
  160.                    (/ *autonorm-target* peak)))
  161.    peak
  162.   ))
  163.  
  164. ;; s-read -- reads a file
  165. (defun s-read (filename &key (time-offset 0) (srate *sound-srate*)
  166.         (dur 10000.0) (nchans 1) (format *default-sf-format*)
  167.         (mode *default-sf-mode*) (bits *default-sf-bits*) (endian NIL))
  168.   (let ((swap 0))
  169.     (cond ((eq endian :big)
  170.            (setf swap (if (bigendianp) 0 1)))
  171.           ((eq endian :little)
  172.            (setf swap (if (bigendianp) 1 0))))
  173.     (if (minusp dur) (error "s-read :dur is negative" dur))
  174.     (snd-read (soundfilename filename) time-offset
  175.             (local-to-global 0) format nchans mode bits swap srate
  176.             dur)))
  177.  
  178. ;; SF-INFO -- print sound file info
  179. ;;
  180. (defun sf-info (filename)
  181.   (let (s format channels mode bits swap srate dur flags)
  182.     (format t "~A:~%" (soundfilename filename))
  183.     (setf s (s-read filename))
  184.     (setf format (car *rslt*))
  185.     (setf channels (cadr *rslt*))
  186.     (setf mode (caddr *rslt*))
  187.     (setf bits (cadddr *rslt*))
  188.     (setf *rslt* (cddddr *rslt*))
  189.     (setf swap (car *rslt*))
  190.     (setf srate (cadr *rslt*))
  191.     (setf dur (caddr *rslt*))
  192.     (setf flags (cadddr *rslt*))
  193.     (format t "Format: ~A~%" 
  194.             (nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX"
  195.                           "NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK"
  196.                           "SDS" "AVR" "SD2" "FLAC" "CAF")))
  197.     (cond ((setp (logand flags snd-head-channels))
  198.            (format t "Channels: ~A~%" channels)))
  199.     (cond ((setp (logand flags snd-head-mode))
  200.            (format t "Mode: ~A~%"
  201.                    (nth mode '("ADPCM" "PCM" "uLaw" "aLaw" "Float" "UPCM"
  202.                                "unknown" "double" "GSM610" "DWVW" "DPCM"
  203.                                "msadpcm")))))
  204.     (cond ((setp (logand flags snd-head-bits))
  205.            (format t "Bits/Sample: ~A~%" bits)))
  206.     (cond ((setp (logand flags snd-head-srate))
  207.            (format t "SampleRate: ~A~%" srate)))
  208.     (cond ((setp (logand flags snd-head-dur))
  209.            (format t "Duration: ~A~%" dur)))
  210.     ))
  211.  
  212. ;; SETP -- tests whether a bit is set (non-zero)
  213. ;
  214. (defun setp (bits) (not (zerop bits)))
  215.  
  216. ;; IS-FILE-SEPARATOR -- is this a file path separation character, e.g. "/"?
  217. ;;
  218. (defun is-file-separator (c)
  219.   (or (eq c *file-separator*)
  220.       (and (eq *file-separator* #\\) ;; if this is windows (indicated by "\")
  221.            (eq c #\/)))) ;; then "/" is also a file separator
  222.  
  223. ;; SOUNDFILENAME -- add default directory to name to get filename
  224. ;;
  225. (defun soundfilename (filename)
  226.   (cond ((= 0 (length filename))
  227.          (break "filename must be at least one character long" filename))
  228.         ((full-name-p filename))
  229.         (t
  230.          ; if sf-dir nonempty and does not end with filename separator,
  231.          ; append one
  232.          (cond ((and (< 0 (length *default-sf-dir*))
  233.                      (not (is-file-separator
  234.                            (char *default-sf-dir* 
  235.                                  (1- (length *default-sf-dir*))))))
  236.                 (setf *default-sf-dir* (strcat *default-sf-dir* (string *file-separator*)))
  237.                 (format t "Warning: appending \"~A\" to *default-sf-dir*~%"
  238.                         *file-separator*)))
  239.          (setf filename (strcat *default-sf-dir* (string filename)))))
  240.   ;; now we have a file name, but it may be relative to current directory, so 
  241.   ;; expand it with the current directory
  242.   (cond ((relative-path-p filename)
  243.          ;; get current working directory and build full name
  244.          (let ((path (setdir ".")))
  245.            (cond (path
  246.                   (setf filename (strcat path (string *file-separator*) 
  247.                                          (string filename))))))))
  248.   filename)
  249.  
  250.  
  251. (setfn s-read-format car)
  252. (setfn s-read-channels cadr)
  253. (setfn s-read-mode caddr)
  254. (setfn s-read-bits cadddr)
  255. (defun s-read-swap (rslt) (car (cddddr rslt)))
  256. (defun s-read-srate (rslt) (cadr (cddddr rslt)))
  257. (defun s-read-dur (rslt) (caddr (cddddr rslt)))
  258. (defun s-read-byte-offset (rslt) (car (cddddr (cddddr rslt))))
  259.  
  260. ;; round is tricky because truncate rounds toward zero as does C
  261. ;; in other words, rounding is down for positive numbers and up
  262. ;; for negative numbers. You can convert rounding up to rounding
  263. ;; down by subtracting one, but this fails on the integers, so
  264. ;; we need a special test if (- x 0.5) is an integer
  265. (defun round (x) 
  266.   (cond ((> x 0) (truncate (+ x 0.5)))
  267.         ((= (- x 0.5) (truncate (- x 0.5))) (truncate x))
  268.         (t (truncate (- x 0.5)))))
  269.  
  270. ;; change defaults for PLAY macro:
  271. (init-global *soundenable* t)
  272. (defun sound-on () (setf *soundenable* t))
  273. (defun sound-off () (setf *soundenable* nil))
  274.  
  275. (defmacro s-add-to (expr maxlen filename &optional (time-offset 0.0))
  276.   `(let ((ny:fname (soundfilename ,filename))
  277.          ny:peak ny:input (ny:offset ,time-offset))
  278.     (format t "Adding sound to ~A at offset ~A~%" 
  279.               ny:fname ,time-offset)
  280.     (setf ny:peak (snd-overwrite '(let ((ny:addend ,expr))
  281.                                    (sum (snd-coterm
  282.                                          (s-read ny:fname
  283.                                           :time-offset ny:offset)
  284.                                          ny:addend)
  285.                                     ny:addend))
  286.                    ,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0))
  287.     (format t "Duration written: ~A~%" (car *rslt*))
  288.     ny:peak))
  289.  
  290.  
  291. (defmacro s-overwrite (expr maxlen filename &optional (time-offset 0.0))
  292.   `(let ((ny:fname (soundfilename ,filename))
  293.          (ny:peak 0.0)
  294.          ny:input ny:rslt ny:offset)
  295.     (format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset)
  296.     (setf ny:offset (s-read-byte-offset ny:rslt))
  297.     (setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname time-offset
  298.                    0, 0, 0, 0.0, 0))
  299.     (format t "Duration written: ~A~%" (car *rslt*))
  300.     ny:peak))
  301.  
  302.  
  303.  
  304.  
  305.